home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / emulators / teco.el < prev    next >
Encoding:
Text File  |  1994-09-20  |  52.7 KB  |  1,922 lines
  1. ;;; teco.el --- Teco interpreter for Gnu Emacs, version 1.
  2.  
  3. (require 'backquote)
  4. ;; This code has been tested some, but no doubt contains a zillion bugs.
  5. ;; You have been warned.
  6.  
  7. ;; Written by Dale R. Worley based on a C implementation by Matt Fichtenbaum.
  8. ;; Please send comments, bug fixes, enhancements, etc. to drw@math.mit.edu.
  9.  
  10. ;; Emacs Lisp version copyright (C) 1991 by Dale R. Worley.
  11. ;; Do what you will with it.
  12.  
  13. ;; Since much of this code is translated from the C version by 
  14. ;; Matt Fichtenbaum, I include his copyright notice:
  15. ;; TECO for Ultrix.   Copyright 1986 Matt Fichtenbaum.
  16. ;; This program and its components belong to GenRad Inc, Concord MA 01742.
  17. ;; They may be copied if this copyright notice is included.
  18.  
  19. ;; To invoke directly, do:
  20. ;; (global-set-key ?\C-z 'teco-command)
  21. ;; (autoload teco-command "teco"
  22. ;;   "Read and execute a Teco command string."
  23. ;;   t nil)
  24.  
  25. ;; Differences from other Tecos:
  26. ;; Character positions in the buffer are numbered in the Emacs way:  The first
  27. ;; character is numbered 1 (or (point-min) if narrowing is in effect).  The
  28. ;; B command returns that number.
  29. ;; Ends of lines are represented by a single character (newline), so C and R
  30. ;; skip over them, rather than 2C and 2R.
  31. ;; All file I/O is left to the underlying Emacs.  Thus, almost all Ex commands
  32. ;; are omitted.
  33.  
  34. ;; Command set:
  35. ;;    NUL    Not a command.
  36. ;;    ^A    Output message to terminal (argument ends with ^A)
  37. ;;    ^C    Exit macro
  38. ;;    ^C^C    Stop execution
  39. ;;    ^D    Set radix to decimal
  40. ;;    ^EA    (match char) Match alphabetics
  41. ;;    ^EC    (match char) Match symbol constituents
  42. ;;    ^ED    (match char) Match numerics
  43. ;;    ^EGq    (match char) Match any char in q-reg
  44. ;;    ^EL    (match char) Match line terminators
  45. ;;    ^EQq    (string char) Use contents of q-reg
  46. ;;    ^ER    (match char) Match alphanumerics
  47. ;;    ^ES    (match char) Match non-null space/tab
  48. ;;    ^EV    (match char) Match lower case alphabetic
  49. ;;    ^EW    (match char) Match upper case alphabetic
  50. ;;    ^EX    (match char) Match any char
  51. ;;    ^G^G    (type-in) Kill command string
  52. ;;    ^G<sp>    (type-in) Retype current command line
  53. ;;    ^G*    (type-in) Retype current command input
  54. ;;    TAB    Insert tab and text
  55. ;;    LF    Line terminator; Ignored in commands
  56. ;;    VT    Ignored in commands
  57. ;;    FF    Ignored in commands
  58. ;;    CR    Ignored in commands
  59. ;;    ^Nx    (match char) Match all but x
  60. ;;    ^O    Set radix to octal
  61. ;;    ^P    Find matching parenthesis
  62. ;;    ^Q    Convert line argument into character argument
  63. ;;    ^Qx    (string char) Use x literally
  64. ;;    n^R    Set radix to n
  65. ;;    :^R    Enter recursive edit
  66. ;;    ^S    -(length of last referenced string)
  67. ;;    ^S    (match char) match separator char
  68. ;;    ^T    Ascii value of next character typed
  69. ;;    n^T    Output Ascii character with value n
  70. ;;    ^U    (type-in) Kill command line
  71. ;;    ^Uq    Put text argument into q-reg
  72. ;;    n^Uq    Put Ascii character 'n' into q-reg
  73. ;;    :^Uq    Append text argument to q-reg
  74. ;;    n:^Uq    Append character 'n' to q-reg
  75. ;;    ^X    Set/get search mode flag
  76. ;;    ^X    (match char) Match any character
  77. ;;    ^Y    Equivalent to '.+^S,.'
  78. ;;    ^Z    Not a Teco command
  79. ;;    ESC    String terminator; absorbs arguments
  80. ;;    ESC ESC    (type-in) End command
  81. ;;    ^\    Not a Teco command
  82. ;;    ^]    Not a Teco command
  83. ;;    ^^x    Ascii value of the character x
  84. ;;    ^_    One's complement (logical NOT)
  85. ;;    !    Define label (argument ends with !)
  86. ;;    "    Start conditional
  87. ;;    n"<    Test for less than zero
  88. ;;    n">    Test for greater than zero
  89. ;;    n"=    Test for equal to zero
  90. ;;    n"A    Test for alphabetic
  91. ;;    n"C    Test for symbol constituent
  92. ;;    n"D    Test for numeric
  93. ;;    n"E    Test for equal to zero
  94. ;;    n"F    Test for false
  95. ;;    n"G    Test for greater than zero
  96. ;;    n"L    Test for less than zero
  97. ;;    n"N    Test for not equal to zero
  98. ;;    n"R    Test for alphanumeric
  99. ;;    n"S    Test for successful
  100. ;;    n"T    Test for true
  101. ;;    n"U    Test for unsuccessful
  102. ;;    n"V    Test for lower case
  103. ;;    n"W    Test for upper case
  104. ;;    #    Logical OR
  105. ;;    $    Not a Teco command
  106. ;;    n%q    Add n to q-reg and return result
  107. ;;    &    Logical AND
  108. ;;    '    End conditional
  109. ;;    (    Expression grouping
  110. ;;    )    Expression grouping
  111. ;;    *    Multiplication
  112. ;;    +    Addition
  113. ;;    ,    Argument separator
  114. ;;    -    Subtraction or negation
  115. ;;    .    Current pointer position
  116. ;;    /    Division
  117. ;;    0-9    Digit
  118. ;;    n<    Iterate n times
  119. ;;    =    Type in decimal
  120. ;;    :=    Type in decimal, no newline
  121. ;;    =    Type in octal
  122. ;;    :=    Type in octal, no newline
  123. ;;    =    Type in hexadecimal
  124. ;;    :=    Type in hexadecimal, no newline
  125. ;;    ::    Make next search a compare
  126. ;;    >    End iteration
  127. ;;    n:A    Get Ascii code of character at relative position n
  128. ;;    B    Character position of beginning of buffer
  129. ;;    nC    Advance n characters
  130. ;;    nD    Delete n characters
  131. ;;    n,mD    Delete characters between n and m
  132. ;;    Gq    Get string from q-reg into buffer
  133. ;;    :Gq    Type out q-reg
  134. ;;    H    Equivalent to 'B,Z'
  135. ;;    I    Insert text argument
  136. ;;    nJ    Move pointer to character n
  137. ;;    nK    Kill n lines
  138. ;;    n,mK    Kill characters between n and m
  139. ;;    nL    Advance n lines
  140. ;;    Mq    Execute string in q-reg
  141. ;;    O    Goto label
  142. ;;    nO    Go to n-th label in list (0-origin)
  143. ;;    Qq    Number in q-reg
  144. ;;    nQq    Ascii value of n-th character in q-reg
  145. ;;    :Qq    Size of text in q-reg
  146. ;;    nR    Back up n characters
  147. ;;    nS    Search
  148. ;;    nT    Type n lines
  149. ;;    n,mT    Type chars from n to m
  150. ;;    nUq    Put number n into q-reg
  151. ;;    nV    Type n lines around pointer
  152. ;;    nXq    Put n lines into q-reg
  153. ;;    n,mXq    Put characters from n to m into q-reg
  154. ;;    n:Xq    Append n lines to q-reg q
  155. ;;    n,m:Xq    Append characters from n to m into q-reg
  156. ;;    Z     Pointer position at end of buffer
  157. ;;    [q    Put q-reg on stack
  158. ;;    \    Value of digit string in buffer
  159. ;;    n\    Convert n to digits and insert in buffer
  160. ;;    ]q    Pop q-reg from stack
  161. ;;    :]q    Test whether stack is empty and return value
  162. ;;    `    Not a Teco command
  163. ;;    a-z    Treated the same as A-Z
  164. ;;    {    Not a Teco command
  165. ;;    |    Conditional 'else'
  166. ;;    }    Not a Teco comand
  167. ;;    ~    Not a Teco command
  168. ;;    DEL    Delete last character typed in
  169.  
  170.  
  171. ;; set a range of elements of an array to a value
  172. (defun teco-set-elements (array start end value)
  173.   (let ((i start))
  174.     (while (<= i end)
  175.       (aset array i value)
  176.       (setq i (1+ i)))))
  177.  
  178. ;; set a range of elements of an array to their indexes plus an offset
  179. (defun teco-set-elements-index (array start end offset)
  180.   (let ((i start))
  181.     (while (<= i end)
  182.       (aset array i (+ i offset))
  183.       (setq i (1+ i)))))
  184.  
  185. (defvar teco-command-string ""
  186.   "The current command string being executed.")
  187.  
  188. (defvar teco-command-pointer nil
  189.   "Pointer into teco-command-string showing next character to be executed.")
  190.  
  191. (defvar teco-ctrl-r 10
  192.   "Current number radix.")
  193.  
  194. (defvar teco-digit-switch nil
  195.   "Set if we have just executed a digit.")
  196.  
  197. (defvar teco-exp-exp nil
  198.   "Expression value preceeding operator.")
  199.  
  200. (defvar teco-exp-val1 nil
  201.   "Current argument value.")
  202.  
  203. (defvar teco-exp-val2 nil
  204.   "Argument before comma.")
  205.  
  206. (defvar teco-exp-flag1 nil
  207.   "t if argument is present.")
  208.  
  209. (defvar teco-exp-flag2 nil
  210.   "t if argument before comma is present.")
  211.  
  212. (defvar teco-exp-op nil
  213.   "Pending arithmetic operation on argument.")
  214.  
  215. (defvar teco-exp-stack nil
  216.   "Stack for parenthesized expressions.")
  217.  
  218. (defvar teco-macro-stack nil
  219.   "Stack for macro invocations.")
  220.  
  221. (defvar teco-mapch-l nil
  222.   "Translation table to lower-case letters.")
  223.  
  224.     (setq teco-mapch-l (make-vector 256 0))
  225.     (teco-set-elements-index teco-mapch-l 0 255 0)
  226.     (teco-set-elements-index teco-mapch-l ?A ?Z (- ?a ?A))
  227.  
  228. (defvar teco-trace nil
  229.   "t if tracing is on.")
  230.  
  231. (defvar teco-at-flag nil
  232.   "t if an @ flag is pending.")
  233.  
  234. (defvar teco-colon-flag nil
  235.   "1 if a : flag is pending, 2 if a :: flag is pending.")
  236.  
  237. (defvar teco-qspec-valid nil
  238.   "Flags describing whether a character is a vaid q-register name.
  239. 3 means yes, 2 means yes but only for file and search operations.")
  240.  
  241.     (setq teco-qspec-valid (make-vector 256 0))
  242.     (teco-set-elements teco-qspec-valid ?a ?z 3)
  243.     (teco-set-elements teco-qspec-valid ?0 ?9 3)
  244.     (aset teco-qspec-valid ?_ 2)
  245.     (aset teco-qspec-valid ?* 2)
  246.     (aset teco-qspec-valid ?% 2)
  247.     (aset teco-qspec-valid ?# 2)
  248.  
  249. (defvar teco-exec-flags 0
  250.   "Flags for iteration in process, ei macro, etc.")
  251.  
  252. (defvar teco-iteration-stack nil
  253.   "Iteration list.")
  254.  
  255. (defvar teco-cond-stack nil
  256.   "Conditional stack.")
  257.  
  258. (defvar teco-qreg-text (make-vector 256 "")
  259.   "The text contents of the q-registers.")
  260.  
  261. (defvar teco-qreg-number (make-vector 256 0)
  262.   "The number contents of the q-registers.")
  263.  
  264. (defvar teco-qreg-stack nil
  265.   "The stack of saved q-registers.")
  266.  
  267. (defconst teco-prompt "*"
  268.   "*Prompt to be used when inputting Teco command.")
  269.  
  270. (defconst teco-exec-1 (make-vector 256 nil)
  271.   "Names of routines handling type 1 characters (characters that are
  272. part of expression processing).")
  273.  
  274. (defconst teco-exec-2 (make-vector 256 nil)
  275.   "Names of routines handling type 2 characters (characters that are
  276. not part of expression processing).")
  277.  
  278. (defvar teco-last-search-string ""
  279.   "Last string searched for.")
  280.  
  281. (defvar teco-last-search-regexp ""
  282.   "Regexp version of teco-last-search-string.")
  283.  
  284. (defmacro teco-define-type-1 (char &rest body)
  285.   "Define the code to process a type 1 character.
  286. Transforms
  287.     (teco-define-type-1 ?x
  288.       code ...)
  289. into
  290.         (defun teco-type-1-x ()
  291.       code ...)
  292. and does
  293.     (aset teco-exec-1 ?x 'teco-type-1-x)"
  294.   (let ((s (intern (concat "teco-type-1-" (char-to-string char)))))
  295.     (` (progn
  296.      (defun (, s) ()
  297.        (,@ body))
  298.      (aset teco-exec-1 (, char) '(, s))))))
  299.  
  300. (defmacro teco-define-type-2 (char &rest body)
  301.   "Define the code to process a type 2 character.
  302. Transforms
  303.     (teco-define-type-2 ?x
  304.       code ...)
  305. into
  306.         (defun teco-type-2-x ()
  307.       code ...)
  308. and does
  309.     (aset teco-exec-2 ?x 'teco-type-2-x)"
  310.   (let ((s (intern (concat "teco-type-2-" (char-to-string char)))))
  311.     (` (progn
  312.      (defun (, s) ()
  313.        (,@ body))
  314.      (aset teco-exec-2 (, char) '(, s))))))
  315.  
  316. (defconst teco-char-types (make-vector 256 0)
  317.   "Define the characteristics of characters, as tested by \":
  318.     1    alphabetic
  319.     2    alphabetic, $, or .
  320.     4    digit
  321.     8    alphabetic or digit
  322.     16    lower-case alphabetic
  323.     32    upper-case alphabetic")
  324.  
  325.     (teco-set-elements teco-char-types ?0 ?9 (+ 4 8))
  326.     (teco-set-elements teco-char-types ?A ?Z (+ 1 2 8 32))
  327.     (teco-set-elements teco-char-types ?a ?z (+ 1 2 8 16))
  328.     (aset teco-char-types ?$ 2)
  329.     (aset teco-char-types ?. 2)
  330.  
  331. (defconst teco-error-texts '(("BNI" . "> not in iteration")
  332.                  ("CPQ" . "Can't pop Q register")
  333.                  ("COF" . "Can't open output file ")
  334.                  ("FNF" . "File not found ")
  335.                  ("IEC" . "Invalid E character")
  336.                  ("IFC" . "Invalid F character")
  337.                  ("IIA" . "Invalid insert arg")
  338.                  ("ILL" . "Invalid command")
  339.                  ("ILN" . "Invalid number")
  340.                  ("IPA" . "Invalid P arg")
  341.                  ("IQC" . "Invalid \" character")
  342.                  ("IQN" . "Invalid Q-reg name")
  343.                  ("IRA" . "Invalid radix arg")
  344.                  ("ISA" . "Invalid search arg")
  345.                  ("ISS" . "Invalid search string")
  346.                  ("IUC" . "Invalid ^ character")
  347.                  ("LNF" . "Label not found")
  348.                  ("MEM" . "Insufficient memory available")
  349.                  ("MRP" . "Missing )")
  350.                  ("NAB" . "No arg before ^_")
  351.                  ("NAC" . "No arg before ,")
  352.                  ("NAE" . "No arg before =")
  353.                  ("NAP" . "No arg before )")
  354.                  ("NAQ" . "No arg before \"")
  355.                  ("NAS" . "No arg before ;")
  356.                  ("NAU" . "No arg before U")
  357.                  ("NFI" . "No file for input")
  358.                  ("NFO" . "No file for output")
  359.                  ("NYA" . "Numeric arg with Y")
  360.                  ("OFO" . "Output file already open")
  361.                  ("PDO" . "Pushdown list overflow")
  362.                  ("POP" . "Pointer off page")
  363.                  ("SNI" . "; not in iteration")
  364.                  ("SRH" . "Search failure ")
  365.                  ("STL" . "String too long")
  366.                  ("UTC" . "Unterminated command")
  367.                  ("UTM" . "Unterminated macro")
  368.                  ("XAB" . "Execution interrupted")
  369.                  ("YCA" . "Y command suppressed")
  370.                  ("IWA" . "Invalid W arg")
  371.                  ("NFR" . "Numeric arg with FR")
  372.                  ("INT" . "Internal error")
  373.                  ("EFI" . "EOF read from std input")
  374.                  ("IAA" . "Invalid A arg")
  375.                  ))
  376.  
  377. (defconst teco-spec-chars 
  378.   [
  379.    0          1          0          0    ; ^@ ^A ^B ^C
  380.    0          64         0          0    ; ^D ^E ^F ^G
  381.    0          2          128        128    ; ^H ^I ^J ^K
  382.    128        0          64         0    ; ^L ^M ^N ^O
  383.    0          64         64         64    ; ^P ^Q ^R ^S
  384.    0          34         0          0    ; ^T ^U ^V ^W
  385.    64         0          0          0    ; ^X ^Y ^Z ^\[
  386.    0          0          1          0    ; ^\ ^\] ^^ ^_
  387.    0          1          16         0    ;    !  \"  # 
  388.    0          0          0          16    ; $  %  &  ' 
  389.    0          0          0          0    ; \(  \)  *  + 
  390.    0          0          0          0    ; ,  -  .  / 
  391.    0          0          0          0    ; 0  1  2  3 
  392.    0          0          0          0    ; 4  5  6  7 
  393.    0          0          0          0    ; 8  9  :  ; 
  394.    16         0          16         0    ; <  =  >  ? 
  395.    1          0          12         0    ; @  A  B  C 
  396.    0          1          1          32    ; D  E  F  G 
  397.    0          6          0          0    ; H  I  J  K 
  398.    0          32         10         2    ; L  M  N  O 
  399.    0          32         4          10    ; P  Q  R  S 
  400.    0          32         0          4    ; T  U  V  W 
  401.    32         0          0          32    ; X  Y  Z  \[ 
  402.    0          32         1          6    ; \  \]  ^  _ 
  403.    0          0          12         0    ; `  a  b  c 
  404.    0          1          1          32    ; d  e  f  g 
  405.    0          6          0          0    ; h  i  j  k 
  406.    0          32         10         2    ; l  m  n  o 
  407.    0          32         4          10    ; p  q  r  s 
  408.    0          32         0          4    ; t  u  v  w 
  409.    32         0          0          0    ; x  y  z  { 
  410.    16         0          0          0    ; |  }  ~  DEL
  411.    ]
  412.   "The special properties of characters:
  413.     1    skipto() special character
  414.     2    command with std text argument
  415.     4    E<char> takes a text argument
  416.     8    F<char> takes a text argument
  417.     16    char causes skipto() to exit
  418.     32    command with q-register argument
  419.     64    special char in search string
  420.     128    character is a line separator")
  421.  
  422.  
  423. (defun teco-execute-command (string)
  424.   "Execute teco command string."
  425.   ;; Initialize everything
  426.   (let ((teco-command-string string)
  427.     (teco-command-pointer 0)
  428.     (teco-digit-switch nil)
  429.     (teco-exp-exp nil)
  430.     (teco-exp-val1 nil)
  431.     (teco-exp-val2 nil)
  432.     (teco-exp-flag1 nil)
  433.     (teco-exp-flag2 nil)
  434.     (teco-exp-op 'start)
  435.     (teco-trace nil)
  436.     (teco-at-flag nil)
  437.     (teco-colon-flag nil)
  438.     (teco-exec-flags 0)
  439.     (teco-iteration-stack nil)
  440.     (teco-cond-stack nil)
  441.     (teco-exp-stack nil)
  442.     (teco-macro-stack nil)
  443.     (teco-qreg-stack nil))
  444.     ;; initialize output
  445.     (teco-out-init)
  446.     ;; execute commands
  447.     (catch 'teco-exit
  448.       (while t
  449.     ;; get next command character
  450.     (let ((cmdc (teco-get-command0 teco-trace)))
  451.       ;; if it's ^, interpret the next character as a control character
  452.       (if (eq cmdc ?^)
  453.           (setq cmdc (logand (teco-get-command teco-trace) 31)))
  454.       (if (and (<= ?0 cmdc) (<= cmdc ?9))
  455.           ;; process a number
  456.           (progn
  457.         (setq cmdc (- cmdc ?0))
  458.         ;; check for invalid digit
  459.         (if (>= cmdc teco-ctrl-r)
  460.             (teco-error "ILN"))
  461.         (if teco-digit-switch
  462.             ;; later digits
  463.             (setq teco-exp-val1 (+ (* teco-exp-val1 teco-ctrl-r) cmdc))
  464.           ;; first digit
  465.           (setq teco-exp-val1 cmdc)
  466.           (setq teco-digit-switch t))
  467.         ;; indicate a value was read in
  468.         (setq teco-exp-flag1 t))
  469.         ;; not a digit
  470.         (setq teco-digit-switch nil)
  471.         ;; cannonicalize the case
  472.         (setq cmdc (aref teco-mapch-l cmdc))
  473.         ;; dispatch on the character, if it is a type 1 character
  474.         (let ((r (aref teco-exec-1 cmdc)))
  475.           (if r
  476.           (funcall r)
  477.         ;; if a value has been entered, process any pending operation
  478.         (if teco-exp-flag1
  479.             (cond ((eq teco-exp-op 'start)
  480.                nil)
  481.               ((eq teco-exp-op 'add)
  482.                (setq teco-exp-val1 (+ teco-exp-exp teco-exp-val1))
  483.                (setq teco-exp-op 'start))
  484.               ((eq teco-exp-op 'sub)
  485.                (setq teco-exp-val1 (- teco-exp-exp teco-exp-val1))
  486.                (setq teco-exp-op 'start))
  487.               ((eq teco-exp-op 'mult)
  488.                (setq teco-exp-val1 (* teco-exp-exp teco-exp-val1))
  489.                (setq teco-exp-op 'start))
  490.               ((eq teco-exp-op 'div)
  491.                (setq teco-exp-val1
  492.                  (if (/= teco-exp-val1 0)
  493.                      (/ teco-exp-exp teco-exp-val1)
  494.                    0))
  495.                (setq teco-exp-op 'start))
  496.               ((eq teco-exp-op 'and)
  497.                (setq teco-exp-val1
  498.                  (logand teco-exp-exp teco-exp-val1))
  499.                (setq teco-exp-op 'start))
  500.               ((eq teco-exp-op 'or)
  501.                (setq teco-exp-val1
  502.                  (logior teco-exp-exp teco-exp-val1))
  503.                (setq teco-exp-op 'start))))
  504.         ;; dispatch on a type 2 character
  505.         (let ((r (aref teco-exec-2 cmdc)))
  506.           (if r
  507.               (funcall r)
  508.             (teco-error "ILL")))))))))))
  509.  
  510. ;; Type 1 commands
  511.  
  512. (teco-define-type-1
  513.  ?\m                    ; CR
  514.  nil)
  515.  
  516. (teco-define-type-1
  517.  ?\n                    ; LF
  518.  nil)
  519.  
  520. (teco-define-type-1
  521.  ?\^k                    ; VT
  522.  nil)
  523.  
  524. (teco-define-type-1
  525.  ?\^l                    ; FF
  526.  nil)
  527.  
  528. (teco-define-type-1
  529.  32                    ; SPC
  530.  nil)
  531.  
  532. (teco-define-type-1
  533.  ?\e                    ; ESC
  534.  (if (teco-peek-command ?\e)
  535.      ;; ESC ESC terminates macro or command
  536.      (teco-pop-macro-stack)
  537.    ;; otherwise, consume argument
  538.    (setq teco-exp-flag1 nil)
  539.    (setq teco-exp-op 'start)))
  540.  
  541. (teco-define-type-1
  542.  ?!                    ; !
  543.  (while (/= (teco-get-command teco-trace) ?!)
  544.    nil))
  545.  
  546. (teco-define-type-1
  547.  ?@                    ; @
  548.  ;; set at-flag
  549.  (setq teco-at-flag t))
  550.  
  551. (teco-define-type-1
  552.  ?:                    ; :
  553.  ;; is it '::'?
  554.  (if (teco-peek-command ?:)
  555.      (progn
  556.        ;; skip second colon
  557.        (teco-get-command teco-trace)
  558.        ;; set flag to show two colons
  559.        (setq teco-colon-flag 2))
  560.    ;; set flag to show one colon
  561.    (setq teco-colon-flag 1)))
  562.  
  563. (teco-define-type-1
  564.  ??                    ; ?
  565.  ;; toggle trace
  566.  (setq teco-trace (not teco-trace)))
  567.  
  568. (teco-define-type-1
  569.  ?.                    ; .
  570.  ;; value is point
  571.  (setq teco-exp-val1 (point)
  572.        teco-exp-flag1 t))
  573.  
  574. (teco-define-type-1
  575.  ?z                    ; z
  576.  ;; value is point-max
  577.  (setq teco-exp-val1 (point-max)
  578.        teco-exp-flag1 t))
  579.  
  580. (teco-define-type-1
  581.  ?b                    ; b
  582.  ;; value is point-min
  583.  (setq teco-exp-val1 (point-min)
  584.        teco-exp-flag1 t))
  585.  
  586. (teco-define-type-1
  587.  ?h                    ; h
  588.  ;; value is b,z
  589.  (setq teco-exp-val1 (point-max)
  590.        teco-exp-val2 (point-min)
  591.        teco-exp-flag1 t
  592.        teco-exp-flag2 t
  593.        teco-exp-op 'start))
  594.  
  595. (teco-define-type-1
  596.  ?\^s                    ; ^s
  597.  ;; value is - length of last insert, etc.
  598.  (setq teco-exp-val1 teco-ctrl-s
  599.        teco-exp-flag1 t))
  600.  
  601. (teco-define-type-1
  602.  ?\^y                    ; ^y
  603.  ;; value is .+^S,.
  604.  (setq teco-exp-val1 (+ (point) teco-ctrl-s)
  605.        teco-exp-val2 (point)
  606.        teco-exp-flag1 t
  607.        teco-exp-flag2 t
  608.        teco-exp-op 'start))
  609.  
  610. (teco-define-type-1
  611.  ?\(                    ; \(
  612.  ;; push expression stack
  613.  (teco-push-exp-stack)
  614.  (setq teco-exp-flag1 nil
  615.        teco-exp-flag2 nil
  616.        teco-exp-op 'start))
  617.  
  618. (teco-define-type-1
  619.  ?\^p                    ; ^p
  620.  (teco-do-ctrl-p))
  621.  
  622. (teco-define-type-1
  623.  ?\C-^                    ; ^^
  624.  ;; get next command character
  625.  (setq teco-exp-val1 (teco-get-command teco-trace)
  626.        teco-exp-flag1 t))
  627.  
  628.  
  629. ;; Type 2 commands
  630. (teco-define-type-2
  631.  ?+                    ; +
  632.  (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
  633.        teco-exp-flag1 nil
  634.        teco-exp-op 'add))
  635.  
  636. (teco-define-type-2
  637.  ?-                    ; -
  638.  (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
  639.        teco-exp-flag1 nil
  640.        teco-exp-op 'sub))
  641.  
  642. (teco-define-type-2
  643.  ?*                    ; *
  644.  (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
  645.        teco-exp-flag1 nil
  646.        teco-exp-op 'mult))
  647.  
  648. (teco-define-type-2
  649.  ?/                    ; /
  650.  (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
  651.        teco-exp-flag1 nil
  652.        teco-exp-op 'div))
  653.  
  654. (teco-define-type-2
  655.  ?&                    ; &
  656.  (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
  657.        teco-exp-flag1 nil
  658.        teco-exp-op 'and))
  659.  
  660. (teco-define-type-2
  661.  ?#                    ; #
  662.  (setq teco-exp-exp (if teco-exp-flag1 teco-exp-val1 0)
  663.        teco-exp-flag1 nil
  664.        teco-exp-op 'or))
  665.  
  666. (teco-define-type-2
  667.  ?\)                    ; \)
  668.  (if (or (not teco-exp-flag1) (not teco-exp-stack))
  669.      (teco-error "NAP"))
  670.  (let ((v teco-exp-val1))
  671.    (teco-pop-exp-stack)
  672.    (setq teco-exp-val1 v
  673.      teco-exp-flag1 t)))
  674.  
  675. (teco-define-type-2
  676.  ?,                    ; ,
  677.  (if (not teco-exp-flag1)
  678.      (teco-error "NAC"))
  679.  (setq teco-exp-val2 teco-exp-val1
  680.        teco-exp-flag2 t
  681.        teco-exp-flag1 nil))
  682.  
  683. (teco-define-type-2
  684.  ?\^_                    ; ^_
  685.  (if (not teco-exp-flag1)
  686.      (teco-error "NAB")
  687.    (setq teco-exp-val1 (lognot teco-exp-val1))))
  688.  
  689. (teco-define-type-2
  690.  ?\^d                    ; ^d
  691.  (setq teco-ctrl-r 10
  692.        teco-exp-flag1 nil
  693.        teco-exp-op 'start))
  694.  
  695. (teco-define-type-2
  696.  ?\^o                    ; ^o
  697.  (setq teco-ctrl-r 8
  698.        teco-exp-flag1 nil
  699.        teco-exp-op 'start))
  700.  
  701. (teco-define-type-2
  702.  ?\^r                    ; ^r
  703.  (if teco-colon-flag
  704.      (progn
  705.        (recursive-edit)
  706.        (setq teco-colon-flag nil))
  707.    (if teco-exp-flag1
  708.        ;; set radix
  709.        (progn
  710.      (if (and (/= teco-exp-val1 8)
  711.           (/= teco-exp-val1 10)
  712.           (/= teco-exp-val1 16))
  713.          (teco-error "IRA"))
  714.      (setq teco-ctrl-r teco-exp-val1
  715.            teco-exp-flag1 nil
  716.            teco-exp-op 'start))
  717.      ;; get radix
  718.      (setq teco-exp-val1 teco-ctrl-r
  719.        teco-exp-flag1 t))))
  720.  
  721. (teco-define-type-2
  722.  ?\^c                    ; ^c
  723.  (if (teco-peek-command ?\^c)
  724.      ;; ^C^C stops execution
  725.      (throw 'teco-exit nil)
  726.    (if teco-macro-stack
  727.        ;; ^C inside macro exits macro
  728.        (teco-pop-macro-stack)
  729.      ;; ^C in command stops execution
  730.      (throw 'teco-exit nil))))
  731.  
  732. (teco-define-type-2
  733.  ?\^x                    ; ^x
  734.  ;; set/get search mode flag
  735.  (teco-set-var 'teco-ctrl-x))
  736.  
  737. (teco-define-type-2
  738.  ?m                    ; m
  739.  (let ((macro-name (teco-get-qspec nil
  740.                    (teco-get-command teco-trace))))
  741.    (teco-push-macro-stack)
  742.    (setq teco-command-string (aref teco-qreg-text macro-name)
  743.      teco-command-pointer 0)))
  744.  
  745. (teco-define-type-2
  746.  ?<                    ; <
  747.  ;; begin iteration
  748.  (if (and teco-exp-flag1 (<= teco-exp-val1 0))
  749.      ;; if this is not to be executed, just skip the
  750.      ;; intervening stuff
  751.      (teco-find-enditer)
  752.    ;; push iteration stack
  753.    (teco-push-iter-stack teco-command-pointer
  754.              teco-exp-flag1 teco-exp-val1)
  755.    ;; consume the argument
  756.    (setq teco-exp-flag1 nil)))
  757.  
  758. (teco-define-type-2
  759.  ?>                    ; >
  760.  ;; end iteration
  761.  (if (not teco-iteration-stack)
  762.      (teco-error "BNI"))
  763.  ;; decrement count and pop conditionally
  764.  (teco-pop-iter-stack nil)
  765.  ;; consume arguments
  766.  (setq teco-exp-flag1 nil
  767.        teco-exp-flag2 nil
  768.        teco-exp-op 'start))
  769.  
  770. (teco-define-type-2
  771.  59                    ; ;
  772.  ;; semicolon iteration exit
  773.  (if (not teco-iteration-stack)
  774.      (teco-error "SNI"))
  775.  ;; if exit
  776.  (if (if (>= (if teco-exp-flag1
  777.          teco-exp-val1
  778.            teco-search-result) 0)
  779.      (not teco-colon-flag)
  780.        teco-colon-flag)
  781.      (progn
  782.        (teco-find-enditer)
  783.        (teco-pop-iter-stack t)))
  784.  ;; consume argument and colon
  785.  (setq teco-exp-flag1 nil
  786.        teco-colon-flag nil
  787.        teco-exp-op 'start))
  788.  
  789. (teco-define-type-2
  790.  ?\"                    ; \"
  791.  ;; must be an argument
  792.  (if (not teco-exp-flag1)
  793.      (teco-error "NAQ"))
  794.  ;; consume argument
  795.  (setq teco-exp-flag1 nil
  796.        teco-exp-op 'start)
  797.  (let* (;; get the test specification
  798.     (c (aref teco-mapch-l (teco-get-command teco-trace)))
  799.     ;; determine whether the test is true
  800.     (test (cond ((eq c ?a)
  801.              (/= (logand (aref teco-char-types teco-exp-val1)
  802.                  1) 0))
  803.             ((eq c ?c)
  804.              (/= (logand (aref teco-char-types teco-exp-val1)
  805.                  2) 0))
  806.             ((eq c ?d)
  807.              (/= (logand (aref teco-char-types teco-exp-val1)
  808.                  4) 0))
  809.             ((or (eq c ?e) (eq c ?f) (eq c ?u) (eq c ?=))
  810.              (= teco-exp-val1 0))
  811.             ((or (eq c ?g) (eq c ?>))
  812.              (> teco-exp-val1 0))
  813.             ((or (eq c ?l) (eq c ?s) (eq c ?t) (eq c ?<))
  814.              (< teco-exp-val1 0))
  815.             ((eq c ?n)
  816.              (/= teco-exp-val1 0))
  817.             ((eq c ?r)
  818.              (/= (logand (aref teco-char-types teco-exp-val1)
  819.                  8) 0))
  820.             ((eq c ?v)
  821.              (/= (logand (aref teco-char-types teco-exp-val1)
  822.                  16) 0))
  823.             ((eq c ?w)
  824.              (/= (logand (aref teco-char-types teco-exp-val1)
  825.                  32) 0))
  826.             (t
  827.              (teco-error "IQC")))))
  828.    (if (not test)
  829.        ;; if the conditional isn't satisfied, read
  830.        ;; to matching | or '
  831.        (let ((ll 1)
  832.          c)
  833.      (while (> ll 0)
  834.        (while (progn (setq c (teco-skipto))
  835.              (and (/= c ?\")
  836.                   (/= c ?|)
  837.                   (/= c ?\')))
  838.          (if (= c ?\")
  839.          (setq ll (1+ ll))
  840.            (if (= c ?\')
  841.            (setq ll (1- ll))
  842.          (if (= ll 1)
  843.              (break))))))))))
  844.  
  845. (teco-define-type-2
  846.  ?'                    ; '
  847.  ;; ignore it if executing
  848.  t)
  849.  
  850. (teco-define-type-2
  851.  ?|                    ; |
  852.  (let ((ll 1)
  853.        c)
  854.    (while (> ll 0)
  855.      (while (progn (setq c (teco-skipto))
  856.            (and (/= c ?\")
  857.             (/= c ?\')))
  858.        nil)
  859.      (if (= c ?\")
  860.      (setq ll (1+ ll))
  861.        (setq ll (1- ll))))))
  862.  
  863. (teco-define-type-2
  864.  ?u                    ; u
  865.  (if (not teco-exp-flag1)
  866.      (teco-error "NAU"))
  867.  (aset teco-qreg-number
  868.        (teco-get-qspec 0 (teco-get-command teco-trace))
  869.        teco-exp-val1)
  870.  (setq teco-exp-flag1 teco-exp-flag2    ; command's value is second arg
  871.        teco-exp-val1 teco-exp-val2
  872.        teco-exp-flag2 nil
  873.        teco-exp-op 'start))
  874.  
  875. (teco-define-type-2
  876.  ?q                    ; q
  877.  ;; Qn is numeric val, :Qn is # of chars, mQn is mth char
  878.  (let ((mm (teco-get-qspec (or teco-colon-flag teco-exp-flag1)
  879.                (teco-get-command teco-trace))))
  880.    (if (not teco-exp-flag1)
  881.        (setq teco-exp-val1 (if teco-colon-flag
  882.                    ;; :Qn
  883.                    (length (aref teco-qreg-text mm))
  884.                  ;; Qn
  885.                  (aref teco-qreg-number mm))
  886.          teco-exp-flag1 t)
  887.      ;; mQn
  888.      (let ((v (aref teco-qreg-text mm)))
  889.        (setq teco-exp-val1 (condition-case nil
  890.                    (aref v teco-exp-val1)
  891.                  (error -1))
  892.          teco-exp-op 'start)))
  893.    (setq teco-colon-flag nil)))
  894.  
  895. (teco-define-type-2
  896.  ?%                    ; %
  897.  (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace)))
  898.     (v (+ (aref teco-qreg-number mm) (teco-get-value 1))))
  899.    (aset teco-qreg-number mm v)
  900.    (setq teco-exp-val1 v
  901.      teco-exp-flag1 t)))
  902.  
  903. (teco-define-type-2
  904.  ?c                    ; c
  905.  (let ((p (+ (point) (teco-get-value 1))))
  906.    (if (or (< p (point-min)) (> p (point-max)))
  907.        (teco-error "POP")
  908.      (goto-char p)
  909.      (setq teco-exp-flag2 nil))))
  910.  
  911. (teco-define-type-2
  912.  ?r                    ; r
  913.  (let ((p (- (point) (teco-get-value 1))))
  914.    (if (or (< p (point-min)) (> p (point-max)))
  915.        (teco-error "POP")
  916.      (goto-char p)
  917.      (setq teco-exp-flag2 nil))))
  918.  
  919. (teco-define-type-2
  920.  ?j                    ; j
  921.  (let ((p (teco-get-value (point-min))))
  922.    (if (or (< p (point-min)) (> p (point-max)))
  923.        (teco-error "POP")
  924.      (goto-char p)
  925.      (setq teco-exp-flag2 nil))))
  926.  
  927. (teco-define-type-2
  928.  ?l                    ; l
  929.  ;; move forward by lines
  930.  (forward-char (teco-lines (teco-get-value 1))))
  931.  
  932. (teco-define-type-2
  933.  ?\C-q                    ; ^q
  934.  ;; number of characters until the nth line feed
  935.  (setq teco-exp-val1 (teco-lines (teco-get-value 1))
  936.        teco-exp-flag1 t))
  937.  
  938. (teco-define-type-2
  939.  ?=                    ; =
  940.  ;; print numeric value
  941.  (if (not teco-exp-flag1)
  942.      (teco-error "NAE"))
  943.  (teco-output (format
  944.            (if (teco-peek-command ?=)
  945.            ;; at least one more =
  946.            (progn
  947.              ;; read past it
  948.              (teco-get-command teco-trace)
  949.              (if (teco-peek-command ?=)
  950.              ;; another?
  951.              (progn
  952.                ;; read it too
  953.                (teco-get-command teco-trace)
  954.                ;; print in hex
  955.                "%x")
  956.                ;; print in octal
  957.                "%o"))
  958.          ;; print in decimal
  959.          "%d")
  960.            teco-exp-val1))
  961.  ;; add newline if no colon
  962.  (if (not teco-colon-flag)
  963.      (teco-output ?\n))
  964.  ;; absorb argument, etc.
  965.  (setq teco-exp-flag1 nil
  966.        teco-exp-flag2 nil
  967.        teco-colon-flag nil
  968.        teco-exp-op 'start))
  969.  
  970. (teco-define-type-2
  971.  ?\t                    ; TAB
  972.  (if exp-flag1
  973.      (teco-error "IIA"))
  974.  (let ((text (teco-get-text-arg)))
  975.    (insert ?\t text)
  976.    (setq teco-ctrl-s (1+ (length text))))
  977.  ;; clear arguments
  978.  (setq teco-colon-flag nil
  979.        teco-exp-flag1 nil
  980.        teco-exp-flag2 nil))
  981.  
  982. (teco-define-type-2
  983.  ?i                    ; i
  984.  (let ((text (teco-get-text-arg)))
  985.    (if teco-exp-flag1
  986.        ;; if a nI$ command
  987.        (progn
  988.      ;; text argument must be null
  989.      (or (string-equal text "") (teco-error "IIA"))
  990.      ;; insert the character
  991.      (insert teco-exp-val1)
  992.      (setq teco-ctrl-s 1)
  993.      ;; consume argument
  994.      (setq teco-exp-op 'start))
  995.      ;; otherwise, insert the text
  996.      (insert text)
  997.      (setq teco-ctrl-s (length text)))
  998.    ;; clear arguments
  999.    (setq teco-colon-flag nil
  1000.      teco-exp-flag1 nil
  1001.      teco-exp-flag2 nil)))
  1002.  
  1003. (teco-define-type-2
  1004.  ?t                    ; t
  1005.  (let ((args (teco-line-args nil)))
  1006.    (teco-output (buffer-substring (car args) (cdr args)))))
  1007.  
  1008. (teco-define-type-2
  1009.  ?v                    ; v
  1010.  (let ((ll (teco-get-value 1)))
  1011.    (teco-output (buffer-substring (+ (point) (teco-lines (- 1 ll)))
  1012.                   (+ (point) (teco-lines ll))))))
  1013.  
  1014. (teco-define-type-2
  1015.  ?\C-a                    ; ^a
  1016.  (teco-output (teco-get-text-arg nil ?\C-a))
  1017.  (setq teco-at-flag nil
  1018.        teco-colon-flag nil
  1019.        teco-exp-flag1 nil
  1020.        teco-exp-flag2 nil
  1021.        teco-exp-op 'start))
  1022.  
  1023. (teco-define-type-2
  1024.  ?d                    ; d
  1025.  (if (not teco-exp-flag2)
  1026.      ;; if only one argument
  1027.      (delete-char (teco-get-value 1))
  1028.    ;; if two arguments, treat as n,mK
  1029.    (let ((ll (teco-line-args 1)))
  1030.      (delete-region (car ll) (cdr ll)))))
  1031.  
  1032. (teco-define-type-2
  1033.  ?k                    ; k
  1034.  (let ((ll (teco-line-args 1)))
  1035.    (delete-region (car ll) (cdr ll))))
  1036.  
  1037. (teco-define-type-2
  1038.  ?\C-u                    ; ^u
  1039.  (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace)))
  1040.     (text-arg (teco-get-text-arg))
  1041.     (text (if (not teco-exp-flag1)
  1042.           text-arg
  1043.         (if (string-equal text-arg "")
  1044.             (char-to-string teco-exp-val1)
  1045.           (teco-error "IIA")))))
  1046.    ;; if :, append to the register
  1047.    (aset teco-qreg-text mm (if teco-colon-flag
  1048.                    (concat (aref teco-qreg-text mm) text)
  1049.                  text))
  1050.    ;; clear various flags
  1051.    (setq teco-exp-flag1 nil
  1052.      teco-at-flag nil
  1053.      teco-colon-flag nil
  1054.      teco-exp-flag1 nil)))
  1055.  
  1056. (teco-define-type-2
  1057.  ?x                    ; x
  1058.  (let* ((mm (teco-get-qspec nil (teco-get-command teco-trace)))
  1059.     (args (teco-line-args 0))
  1060.     (text (buffer-substring (car args) (cdr args))))
  1061.    ;; if :, append to the register
  1062.    (aset teco-qreg-text mm (if teco-colon-flag
  1063.                    (concat (aref teco-qreg-text mm) text)
  1064.                  text))
  1065.    ;; clear various flags
  1066.    (setq teco-exp-flag1 nil
  1067.      teco-at-flag nil
  1068.      teco-colon-flag nil
  1069.      teco-exp-flag1 nil)))
  1070.  
  1071. (teco-define-type-2
  1072.  ?g                    ; g
  1073.  (let ((mm (teco-get-qspec t (teco-get-command teco-trace))))
  1074.    (if teco-colon-flag
  1075.        (teco-output (aref teco-qreg-text mm))
  1076.      (insert (aref teco-qreg-text mm)))
  1077.    (setq teco-colon-flag nil)))
  1078.  
  1079. (teco-define-type-2
  1080.  ?\[                    ; \[
  1081.  (let ((mm (teco-get-qspec t (teco-get-command teco-trace))))
  1082.    (setq teco-qreg-stack
  1083.      (cons (cons (aref teco-qreg-text mm)
  1084.              (aref teco-qreg-number mm))
  1085.            teco-qreg-stack))))
  1086.  
  1087. (teco-define-type-2
  1088.  ?\]                    ; \]
  1089.  (let ((mm (teco-get-qspec t (teco-get-command teco-trace))))
  1090.    (if teco-colon-flag
  1091.        (setq teco-exp-flag1 t
  1092.          teco-exp-val1 (if teco-qreg-stack -1 0))
  1093.      (if teco-qreg-stack
  1094.      (let ((pop (car teco-qreg-stack)))
  1095.        (aset teco-qreg-text mm (car pop))
  1096.        (aset teco-qreg-number mm (cdr pop))
  1097.        (setq teco-qreg-stack (cdr teco-qreg-stack)))
  1098.        (teco-error "CPQ")))
  1099.    (setq teco-colon-flag nil)))
  1100.  
  1101. (teco-define-type-2
  1102.  ?\\                    ; \
  1103.  (if (not teco-exp-flag1)
  1104.      ;; no argument; read number
  1105.      (let ((p (point))
  1106.        (sign +1)
  1107.        (n 0)
  1108.        c)
  1109.        (setq c (char-after p))
  1110.        (if c
  1111.        (if (= c ?+)
  1112.            (setq p (1+ p))
  1113.          (if (= c ?-)
  1114.          (setq p (1+ p)
  1115.                sign -1))))
  1116.        (cond
  1117.     ((= teco-ctrl-r 8) 
  1118.      (while (progn
  1119.           (setq c (char-after p))
  1120.           (and c (>= c ?0) (<= c ?7)))
  1121.        (setq p (1+ p)
  1122.          n (+ c -48 (* n 8)))))
  1123.     ((= teco-ctrl-r 10) 
  1124.      (while (progn
  1125.           (setq c (char-after p))
  1126.           (and c (>= c ?0) (<= c ?9)))
  1127.        (setq p (1+ p)
  1128.          n (+ c -48 (* n 10)))))
  1129.     (t
  1130.      (while (progn
  1131.           (setq c (char-after p))
  1132.           (and c
  1133.                (or
  1134.             (and (>= c ?0) (<= c ?9))
  1135.             (and (>= c ?a) (<= c ?f))
  1136.             (and (>= c ?A) (<= c ?F)))))
  1137.        (setq p (1+ p)
  1138.          n (+ c (if (> c ?F)
  1139.                 ;; convert 'a' to 10
  1140.                 -87 
  1141.               (if (> c ?9)
  1142.                   ;; convert 'A' to 10
  1143.                   -55
  1144.                 ;; convert '0' to 0
  1145.                 -48))
  1146.               (* n 16))))))
  1147.        (setq teco-exp-val1 (* n sign)
  1148.          teco-exp-flag1 t
  1149.          teco-ctrl-s (- (point) p)))
  1150.    ;; argument: insert it as a digit string
  1151.    (insert (format (cond 
  1152.             ((= teco-ctrl-r 8) "%o")
  1153.             ((= teco-ctrl-r 10) "%d")
  1154.             (t "%x"))
  1155.            teco-exp-val1))
  1156.    (setq teco-exp-flag1 nil
  1157.      teco-exp-op 'start)))
  1158.  
  1159. (teco-define-type-2
  1160.  ?\C-t                    ; ^t
  1161.  (if teco-exp-flag1
  1162.      ;; type a character
  1163.      (progn
  1164.        (teco-output teco-exp-val1)
  1165.        (setq teco-exp-flag1 nil))
  1166.    ;; input a character
  1167.    (let* ((echo-keystrokes 0)
  1168.       (c (read-char)))
  1169.      (teco-output c)
  1170.      (setq teco-exp-val1 c
  1171.        teco-exp-flag1 t))))
  1172.  
  1173. (teco-define-type-2
  1174.  ?s                    ; s
  1175.  (let ((arg (teco-get-text-arg))
  1176.        (count (if teco-exp-flag1 teco-expr-val1 1))
  1177.        regexp)
  1178.    (if (not (string-equal arg ""))
  1179.        (setq regexp (teco-parse-search-string arg)
  1180.          teco-last-search-string arg
  1181.          teco-last-search-regexp regexp)
  1182.      (setq regexp (teco-last-search-regexp)
  1183.        arg teco-last-search-string))
  1184.    (let ((p (point))
  1185.      (result (cond
  1186.           ((> count 0)
  1187.            (re-search-forward regexp nil t count))
  1188.           ((< count 0)
  1189.            (re-search-backward regexp nil t count))
  1190.           (t
  1191.            ;; 0s always is successful
  1192.            t))))
  1193.      ;; if ::s, restore point
  1194.      (if (eq teco-colon-flag 2)
  1195.      (goto-char p))
  1196.      ;; if no real or implied colon, error if not found
  1197.      (if (and (not result)
  1198.           (not teco-colon-flag)
  1199.           (/= (teco-peekcmdc) 34))
  1200.      (teco-error "SRH"))
  1201.      ;; set return results
  1202.      (setq teco-exp-flag2 nil
  1203.        teco-colon-flag nil
  1204.        teco-at-flag nil
  1205.        teco-exp-op 'start)
  1206.      (if teco-colon-flag
  1207.      (setq teco-exp-flag1 t
  1208.            teco-exp-val1 (if result -1 0))
  1209.        (setq teco-exp-flag1 nil)))))
  1210.  
  1211. (defun teco-parse-search-string (s)
  1212.   (let ((i 0)
  1213.     (l (length s))
  1214.     (r "")
  1215.     c)
  1216.     (while (< i l)
  1217.       (setq r (concat r (teco-parse-search-string-1))))
  1218.     r))
  1219.  
  1220. (defun teco-parse-search-string-1 ()
  1221.   (if (>= i l)
  1222.       (teco-error "ISS"))
  1223.   (setq c (aref s i))
  1224.   (setq i (1+ i))
  1225.   (cond
  1226.    ((eq c ?\C-e)            ; ^E - special match characters
  1227.     (teco-parse-search-string-e))
  1228.    ((eq c ?\C-n)            ; ^Nx - match all but x
  1229.     (teco-parse-search-string-n))
  1230.    ((eq c ?\C-q)            ; ^Qx - use x literally
  1231.     (teco-parse-search-string-q))
  1232.    ((eq c ?\C-s)            ; ^S - match separator chars
  1233.     "[^A-Za-z0-9]")
  1234.    ((eq c ?\C-x)            ; ^X - match any character
  1235.     "[\000-\377]")
  1236.    (t                    ; ordinary character
  1237.     (teco-parse-search-string-char c))))
  1238.  
  1239. (defun teco-parse-search-string-char (c)
  1240.   (regexp-quote (char-to-string c)))
  1241.  
  1242. (defun teco-parse-search-string-q ()
  1243.   (if (>= i l)
  1244.       (teco-error "ISS"))
  1245.   (setq c (aref s i))
  1246.   (setq i (1+ i))
  1247.   (teco-parse-search-string-char c))
  1248.  
  1249. (defun teco-parse-search-string-e ()
  1250.   (if (>= i l)
  1251.       (teco-error "ISS"))
  1252.   (setq c (aref s i))
  1253.   (setq i (1+ i))
  1254.   (cond
  1255.    ((or (eq c ?a) (eq c ?A))        ; ^EA - match alphabetics
  1256.     "[A-Za-z]")
  1257.    ((or (eq c ?c) (eq c ?C))        ; ^EC - match symbol constituents
  1258.     "[A-Za-z.$]")
  1259.    ((or (eq c ?d) (eq c ?D))        ; ^ED - match numerics
  1260.     "[0-9]")
  1261.    ((eq c ?g)                ; ^EGq - match any char in q-reg
  1262.     (teco-parse-search-string-e-g))
  1263.    ((or (eq c ?l) (eq c ?L))        ; ^EL - match line terminators
  1264.     "[\012\013\014]")
  1265.    ((eq c ?q)                ; ^EQq - use contents of q-reg
  1266.     (teco-parse-search-string-e-q))
  1267.    ((eq c ?r)                ; ^ER - match alphanumerics
  1268.     "[A-Za-z0-9]")
  1269.    ((eq c ?s)                ; ^ES - match non-null space/tab seq
  1270.     "[ \t]+")
  1271.    ((eq c ?v)                ; ^EV - match lower case alphabetic
  1272.     "[a-z]")
  1273.    ((eq c ?w)                ; ^EW - match upper case alphabetic
  1274.     "[A-Z]")
  1275.    ((eq c ?x)                ; ^EX - match any character
  1276.     "[\000-\377]")
  1277.    (t
  1278.     (teco-error "ISS"))))
  1279.  
  1280. (defun teco-parse-search-string-e-q ()
  1281.   (if (>= i l)
  1282.       (teco-error "ISS"))
  1283.   (setq c (aref s i))
  1284.   (setq i (1+ i))
  1285.   (regexp-quote (aref reco:q-reg-text c)))
  1286.  
  1287. (defun teco-parse-search-string-e-g ()
  1288.   (if (>= i l)
  1289.       (teco-error "ISS"))
  1290.   (setq c (aref s i))
  1291.   (setq i (1+ i))
  1292.   (let* ((q (aref teco-qreg-text c))
  1293.      (len (length q))
  1294.      (null (= len 0))
  1295.      (one-char (= len 1))
  1296.      (dash-present (string-match "-" q))
  1297.      (caret-present (string-match "\\^" q))
  1298.      (outbracket-present (string-match "]" q))
  1299.      p)
  1300.     (cond
  1301.      (null
  1302.       "[^\000-\377]")
  1303.      (one-char
  1304.       (teco-parse-search-string-char c))
  1305.      (t
  1306.       (while (setq p (string-match "^]\\^"))
  1307.     (setq q (concat (substring q 1 p) (substring q (1+ p)))))
  1308.       (concat
  1309.        "["
  1310.        (if outbracket-present "]" "")
  1311.        (if dash-present "---" "")
  1312.        q
  1313.        (if caret-present "^" ""))))))
  1314.  
  1315. (defun teco-parse-search-string-n ()
  1316.   (let ((p (teco-parse-search-string-1)))
  1317.     (cond
  1318.      ((= (aref p 0) ?\[)
  1319.       (if (= (aref p 1) ?^)
  1320.       ;; complement character set
  1321.       (if (= (length p) 4)
  1322.           ;; complement of one character
  1323.           (teco-parse-search-string-char (aref p 2))
  1324.         ;; complement of more than one character
  1325.         (concat "[" (substring p 2)))
  1326.     ;; character set - invert it
  1327.       (concat "[^" (substring p 1))))
  1328.      ((= (aref p 0) ?\\)
  1329.       ;; single quoted character
  1330.       (concat "[^" (substring p 1) "]"))
  1331.      (t
  1332.       ;; single character
  1333.       (if (string-equal p "-")
  1334.       "[^---]"
  1335.     (concat "[^" p "]"))))))
  1336.  
  1337. (teco-define-type-2
  1338.  ?o                    ; o
  1339.  (let ((label (teco-get-text-arg))
  1340.        (index (and teco-exp-flag1 teco-exp-val1)))
  1341.    (setq teco-exp-flag1 nil)
  1342.    ;; handle computed goto by extracting the proper label
  1343.    (if index
  1344.        (if (< index 0)
  1345.        ;; argument < 0 is a noop
  1346.        (setq label "")
  1347.      ;; otherwise, find the n-th label (0-origin)
  1348.      (setq label (concat label ","))
  1349.      (let ((p 0))
  1350.        (while (and (> index 0)
  1351.                (setq p (string-match "," label p))
  1352.                (setq p (1+ p)))
  1353.          (setq index (1- index)))
  1354.        (setq q (string-match "," label p))
  1355.        (setq label (substring label p q)))))
  1356.    ;; if the label is non-null, find the correct label
  1357.    ;; start from beginning of iteration or macro, and look for tag
  1358.    (setq teco-command-pointer
  1359.      (if teco-iteration-stack
  1360.          ;; if in iteration, start at beginning of iteration
  1361.          (aref (car teco-iteration-stack) 0)
  1362.        ;; if not in iteration, start at beginning of command or macro
  1363.        0))
  1364.    ;; search for tag
  1365.    (catch 'label
  1366.      (let ((level 0)
  1367.        c p l)
  1368.        ;; look for interesting things, including !
  1369.        (while t
  1370.      (setq c (teco-skipto t))
  1371.      (cond
  1372.       ((= c ?<)            ; start of iteration
  1373.        (setq level (1+ level)))
  1374.       ((= c ?>)            ; end of iteration
  1375.        (if (= level 0)
  1376.            (teco-pop-iter-stack t)
  1377.          (setq level (1- level))))
  1378.       ((= c ?!)            ; start of tag
  1379.        (setq p (string-match "!" teco-command-string teco-command-pointer))
  1380.        (if (and p
  1381.             (string-equal label (substring teco-command-string
  1382.                            teco-command-pointer
  1383.                            p)))
  1384.            (progn
  1385.          (setq teco-command-pointer (1+ p))
  1386.          (throw 'label nil))))))))))
  1387.  
  1388. (teco-define-type-2
  1389.  ?a                    ; :a
  1390.  ;; 'a' must be used as ':a'
  1391.  (if (and teco-exp-flag1 teco-colon-flag)
  1392.      (let ((char (+ (point) teco-exp-val1)))
  1393.        (setq teco-exp-val1
  1394.          (if (and (>= char (point-min))
  1395.               (< char (point-max)))
  1396.          (char-after char)
  1397.            -1)
  1398.          teco-colon-flag nil))
  1399.    (teco-error "ILL")))
  1400.  
  1401.  
  1402. ;; Routines to get next character from command buffer
  1403. ;; getcmdc0, when reading beyond command string, pops
  1404. ;; macro stack and continues.
  1405. ;; getcmdc, in similar circumstances, reports an error.
  1406. ;; If pushcmdc() has returned any chars, read them first
  1407. ;; routines type characters as read, if argument != 0.
  1408.  
  1409. (defun teco-get-command0 (trace)
  1410.   ;; get the next character
  1411.   (let (char)
  1412.     (while (not (condition-case nil
  1413.             (setq char (aref teco-command-string teco-command-pointer))
  1414.           ;; if we've exhausted the string, pop the macro stack
  1415.           ;; if we exhaust the macro stack, exit
  1416.           (error (teco-pop-macro-stack)
  1417.              nil))))
  1418.     ;; bump the command pointer
  1419.     (setq teco-command-pointer (1+ teco-command-pointer))
  1420.     ;; trace, if requested
  1421.     (and trace (teco-trace-type char))
  1422.     ;; return the character
  1423.     char))
  1424.  
  1425. ;;     while (cptr.dot >= cptr.z)        /* if at end of this level, pop macro stack
  1426. ;;         {
  1427. ;;         if (--msp < &mstack[0])        /* pop stack; if top level
  1428. ;;             {
  1429. ;;             msp = &mstack[0];        /* restore stack pointer
  1430. ;;             cmdc = ESC;                /* return an ESC (ignored)
  1431. ;;             exitflag = 1;            /* set to terminate execution
  1432. ;;             return(cmdc);            /* exit "while" and return
  1433. ;;             }
  1434. ;;         }
  1435. ;;     cmdc = cptr.p->ch[cptr.c++];        /* get char
  1436. ;;     ++cptr.dot;                            /* increment character count
  1437. ;;     if (trace) type_char(cmdc);            /* trace
  1438. ;;     if (cptr.c > CELLSIZE-1)            /* and chain if need be
  1439. ;;         {
  1440. ;;         cptr.p = cptr.p->f;
  1441. ;;         cptr.c = 0;
  1442. ;;         }
  1443. ;;     return(cmdc);
  1444. ;;     }
  1445.  
  1446.  
  1447. (defun teco-get-command (trace)
  1448.   ;; get the next character
  1449.   (let ((char (condition-case nil
  1450.           (aref teco-command-string teco-command-pointer)
  1451.         ;; if we've exhausted the string, give error
  1452.         (error
  1453.          (teco-error (if teco-macro-stack "UTM" "UTC"))))))
  1454.     ;; bump the command pointer
  1455.     (setq teco-command-pointer (1+ teco-command-pointer))
  1456.     ;; trace, if requested
  1457.     (and trace (teco-trace-type char))
  1458.     ;; return the character
  1459.     char))
  1460.  
  1461. ;; char getcmdc(trace)
  1462. ;;     {
  1463. ;;     if (cptr.dot++ >= cptr.z) ERROR((msp <= &mstack[0]) ? E_UTC : E_UTM);
  1464. ;;     else
  1465. ;;         {
  1466. ;;         cmdc = cptr.p->ch[cptr.c++];    /* get char
  1467. ;;         if (trace) type_char(cmdc);        /* trace
  1468. ;;         if (cptr.c > CELLSIZE-1)        /* and chain if need be
  1469. ;;             {
  1470. ;;             cptr.p = cptr.p->f;
  1471. ;;             cptr.c = 0;
  1472. ;;             }
  1473. ;;         }
  1474. ;;     return(cmdc);
  1475. ;;     }
  1476.  
  1477.  
  1478. ;; peek at next char in command string, return 1 if it is equal
  1479. ;; (case independent) to argument
  1480.  
  1481. (defun teco-peek-command (arg)
  1482.   (condition-case nil
  1483.       (eq (aref teco-mapch-l (aref teco-command-string teco-command-pointer))
  1484.       (aref teco-mapch-l arg))
  1485.     (error nil)))
  1486.  
  1487. ;; int peekcmdc(arg)
  1488. ;;     char arg;
  1489. ;;     {
  1490. ;;     return(((cptr.dot < cptr.z) && (mapch_l[cptr.p->ch[cptr.c]] == mapch_l[arg])) ? 1 : 0);
  1491. ;;     }
  1492.  
  1493. (defun teco-get-text-arg (&optional term-char default-term-char)
  1494.   ;; figure out what the terminating character is
  1495.   (setq teco-term-char (or term-char
  1496.                (if teco-at-flag
  1497.                    (teco-get-command teco-trace)
  1498.                  (or default-term-char
  1499.                  ?\e)))
  1500.     teco-at_flag nil)
  1501.   (let ((s "")
  1502.     c)
  1503.     (while (progn
  1504.          (setq c (teco-get-command teco-trace))
  1505.          (/= c teco-term-char))
  1506.       (setq s (concat s (char-to-string c))))
  1507.     s))
  1508.  
  1509.  
  1510. ;; Routines to manipulate the stacks
  1511.  
  1512. ;; Pop the macro stack.  Throw to 'teco-exit' if the stack is empty.
  1513. (defun teco-pop-macro-stack ()
  1514.   (if teco-macro-stack
  1515.       (let ((frame (car teco-macro-stack)))
  1516.     (setq teco-macro-stack (cdr teco-macro-stack)
  1517.           teco-command-string (aref frame 0)
  1518.           teco-command-pointer (aref frame 1)
  1519.           teco-exec-flags (aref frame 2)
  1520.           teco-iteration-stack (aref frame 3)
  1521.           teco-cond-stack (aref frame 4)))
  1522.     (throw 'teco-exit nil)))
  1523.  
  1524. ;; Push the macro stack.
  1525. (defun teco-push-macro-stack ()
  1526.   (setq teco-macro-stack
  1527.     (cons (vector teco-command-string
  1528.               teco-command-pointer
  1529.               teco-exec-flags
  1530.               teco-iteration-stack
  1531.               teco-cond-stack)
  1532.           teco-macro-stack)))
  1533.  
  1534. ;; Pop the expression stack.
  1535. (defun teco-pop-exp-stack ()
  1536.   (let ((frame (car teco-exp-stack)))
  1537.     (setq teco-exp-stack (cdr teco-exp-stack)
  1538.       teco-exp-val1 (aref frame 0)
  1539.       teco-exp-flag1 (aref frame 1)
  1540.       teco-exp-val2 (aref frame 2)
  1541.       teco-exp-flag2 (aref frame 3)
  1542.       teco-exp-exp (aref frame 4)
  1543.       teco-exp-op (aref frame 5))))
  1544.  
  1545. ;; Push the expression stack.
  1546. (defun teco-push-exp-stack ()
  1547.   (setq teco-exp-stack
  1548.     (cons (vector teco-exp-val1
  1549.               teco-exp-flag1
  1550.               teco-exp-val2
  1551.               teco-exp-flag2
  1552.               teco-exp-exp
  1553.               teco-exp-op)
  1554.           teco-exp-stack)))
  1555.  
  1556. ;; Pop the iteration stack
  1557. ;; if arg t, exit unconditionally
  1558. ;; else check exit conditions and exit or reiterate
  1559. (defun teco-pop-iter-stack (arg)
  1560.   (let ((frame (car teco-iteration-stack)))
  1561.     (if (or arg
  1562.         (not (aref frame 1))
  1563.         ;; test against 1, since one iteration has already been done
  1564.         (<= (aref frame 2) 1))
  1565.     ;; exit iteration
  1566.     (setq teco-iteration-stack (cdr teco-iteration-stack))
  1567.       ;; continue with iteration
  1568.       ;; decrement count
  1569.       (aset frame 2 (1- (aref frame 2)))
  1570.       ;; reset command pointer
  1571.       (setq teco-command-pointer (aref frame 0)))))
  1572.  
  1573. ;; Push the iteration stack
  1574. (defun teco-push-iter-stack (pointer flag count)
  1575.   (setq teco-iteration-stack
  1576.     (cons (vector pointer
  1577.               flag
  1578.               count)
  1579.           teco-iteration-stack)))          
  1580.  
  1581. (defun teco-find-enditer ()
  1582.   (let ((icnt 1)
  1583.     c)
  1584.     (while (> icnt 0)
  1585.       (while (progn (setq c (teco-skipto))
  1586.             (and (/= c ?<)
  1587.              (/= c ?>)))
  1588.     (if (= c ?<)
  1589.         (setq icnt (1+ icnt))
  1590.       (setq icnt (1- icnt)))))))
  1591.  
  1592.  
  1593. ;; I/O routines
  1594.  
  1595. (defvar teco-output-buffer (get-buffer-create "*Teco Output*")
  1596.   "The buffer into which Teco output is written.")
  1597.  
  1598. (defun teco-out-init ()
  1599.   ;; Recreate the teco output buffer, if necessary
  1600.   (setq teco-output-buffer (get-buffer-create "*Teco Output*"))
  1601.   (save-excursion
  1602.     (set-buffer teco-output-buffer)
  1603.     ;; get a fresh line in output buffer
  1604.     (goto-char (point-max))
  1605.     (insert ?\n)
  1606.     ;; remember where to start displaying
  1607.     (setq teco-output-start (point))
  1608.     ;; clear minibuffer, in case we have to display in it
  1609.     (save-window-excursion
  1610.       (select-window (minibuffer-window))
  1611.       (erase-buffer))
  1612.     ;; if output is visible, position it correctly
  1613.     (let ((w (get-buffer-window teco-output-buffer)))
  1614.       (if w
  1615.       (progn
  1616.         (set-window-start w teco-output-start)
  1617.         (set-window-point w teco-output-start))))))
  1618.  
  1619. (defun teco-output (s)
  1620.   (let ((w (get-buffer-window teco-output-buffer))
  1621.     (b (current-buffer))
  1622.     (sw (selected-window)))
  1623.     ;; Put the text in the output buffer
  1624.     (set-buffer teco-output-buffer)
  1625.     (goto-char (point-max))
  1626.     (insert s)
  1627.     (let ((p (point)))
  1628.       (set-buffer b)
  1629.       (if w
  1630.       ;; if output is visible, move the window point to the end
  1631.       (set-window-point w p)
  1632.     ;; Otherwise, we have to figure out how to display the text
  1633.     ;; Has a newline followed by another character been added to the
  1634.     ;; output buffer?  If so, we have to make the output buffer visible.
  1635.     (if (save-excursion
  1636.           (set-buffer teco-output-buffer)
  1637.           (backward-char 1)
  1638.           (search-backward "\n" teco-output-start t))
  1639.         ;; a newline has been seen, clear the minibuffer and make the
  1640.         ;; output buffer visible
  1641.         (progn
  1642.           (save-window-excursion
  1643.         (select-window (minibuffer-window))
  1644.         (erase-buffer))
  1645.           (let ((pop-up-windows t))
  1646.         (pop-to-buffer teco-output-buffer)
  1647.         (goto-char p)
  1648.         (set-window-start w teco-output-start)
  1649.         (set-window-point w p)
  1650.         (select-window sw)))
  1651.       ;; a newline has not been seen, add output to minibuffer
  1652.       (save-window-excursion
  1653.         (select-window (minibuffer-window))
  1654.         (goto-char (point-max))
  1655.         (insert s)))))))
  1656.  
  1657. ;; Output a character of tracing information
  1658. (defun teco-trace-type (c)
  1659.   (teco-output (if (= c ?\e)
  1660.         ?$
  1661.           c)))
  1662.  
  1663. ;; Report an error
  1664. (defun teco-error (code)
  1665.   (let ((text (cdr (assoc code teco-error-texts))))
  1666.     (teco-output (concat (if (save-excursion (set-buffer teco-output-buffer)
  1667.                          (/= (point) teco-output-start))
  1668.                  "\n"
  1669.                "")
  1670.              "? " code " " text))
  1671.     (beep)
  1672.     (if debug-on-error (debug nil code text))
  1673.     (throw 'teco-exit nil)))
  1674.  
  1675.  
  1676. ;; Utility routines
  1677.  
  1678. ;; copy characters from command string to buffer
  1679. (defun teco-moveuntil (string pointer terminate trace)
  1680.   (let ((count 0))
  1681.     (condition-case nil
  1682.     (while (/= (aref string pointer) terminate)
  1683.       (and teco-trace (teco-trace-type (aref string pointer)))
  1684.       (insert (aref string pointer))
  1685.       (setq pointer (1+ pointer))
  1686.       (setq count (1+ count)))
  1687.       (error (teco-error (if teco-macro-stack "UTM" "UTC"))))
  1688.     count))
  1689.  
  1690. ;; Convert character to q-register name
  1691. ;; If file-or-search is t, allow _, *, %, #
  1692. (defun teco-get-qspec (file-or-search char)
  1693.   ;; lower-case char
  1694.   (setq char (aref teco-mapch-l char))
  1695.   ;; test that it's valid
  1696.   (if (= (logand (aref teco-qspec-valid char) (if file-or-search 2 1)) 0)
  1697.       (teco-error "IQN"))
  1698.   char)
  1699.  
  1700. ;; Set or get value of a variable
  1701. (defun teco-set-var (var)
  1702.   (if teco-exp-flag1
  1703.       (progn
  1704.     (if teco-exp-flag2
  1705.         ;; if two arguments, they they are <clear bits>, <set bits>
  1706.         (set var (logior (logand (symbol-value var) (lognot teco-exp-val2))
  1707.                  teco-exp-val1))
  1708.       ;; if one argument, it is the new value
  1709.       (set var teco-exp-val1))
  1710.     ;; consume argument(s)
  1711.     (setq teco-exp-flag2 nil
  1712.           teco-exp-flag1 nil))
  1713.     ;; if no arguments, fetch the value
  1714.     (setq teco-exp-val1 (symbol-value var)
  1715.       teco-exp-flag1 t)))
  1716.  
  1717. ;; Get numeric argument
  1718. (defun teco-get-value (default)
  1719.   (prog1
  1720.       (if teco-exp-flag1
  1721.       teco-exp-val1
  1722.     (if (eq teco-exp-op 'sub)
  1723.         (- default)
  1724.       default))
  1725.     ;; consume argument
  1726.     (setq teco-exp-flag1 nil
  1727.       teco-exp-op 'start)))
  1728.  
  1729. ;; Get argument measuring in lines
  1730. (defun teco-lines (r)
  1731.   (- (save-excursion
  1732.        (if (> r 0)
  1733.        (if (search-forward "\n" nil t r)
  1734.            (point)
  1735.          (point-max))
  1736.      (if (search-backward "\n" nil t (- 1 r))
  1737.          (1+ (point))
  1738.        (point-min))))
  1739.      (point)))
  1740.  
  1741. ;; routine to handle args for K, T, X, etc.
  1742. ;; if two args, 'char x' to 'char y'
  1743. ;; if just one arg, then n lines (default 1)
  1744. (defun teco-line-args (arg)
  1745.   (if teco-exp-flag2
  1746.       (cons teco-exp-val1 teco-exp-val2)
  1747.     (cons (point) (+ (point) (teco-lines (if teco-exp-flag1
  1748.                          teco-exp-val1
  1749.                        1))))))
  1750.  
  1751. ;; routine to skip to next ", ', |, <, or >
  1752. ;; skips over these chars embedded in text strings
  1753. ;; stops in ! if argument is t
  1754. ;; returns character found
  1755. (defun teco-skipto (&optional arg)
  1756.   (catch 'teco-skip
  1757.     (let (;; "at" prefix
  1758.       (atsw nil)
  1759.       ;; temp attributes
  1760.       ta
  1761.       ;; terminator
  1762.       term
  1763.       skipc)
  1764.       (while t                ; forever
  1765.     (while (progn
  1766.          (setq skipc (teco-get-command nil)
  1767.                ta (aref teco-spec-chars skipc))
  1768.          ;; if char is ^, treat next char as control
  1769.          (if (eq skipc ?^)
  1770.              (setq skipc (logand 31 (teco-get-command nil))
  1771.                ta (aref teco-spec-chars skipc)))
  1772.          (= (logand ta 51) 0))    ; read until something interesting
  1773.                     ; found
  1774.       nil)
  1775.     (if (/= (logand ta 32) 0)
  1776.         (teco-get-command nil))    ; if command takes a Q spec,
  1777.                     ; skip the spec
  1778.     (if (/= (logand ta 16) 0)    ; sought char found: quit 
  1779.         (progn
  1780.           (if (= skipc ?\")        ; quote must skip next char
  1781.           (teco-get-command nil))
  1782.           (throw 'teco-skip skipc)))
  1783.     (if (/= (logand ta 1) 0)    ; other special char
  1784.         (cond
  1785.          ((eq skipc ?@)        ; use alternative text terminator
  1786.           (setq atsw t))
  1787.          ((eq skipc ?\C-^)        ; ^^ is value of next char
  1788.                     ; skip that char
  1789.           (teco-get-command nil))
  1790.          ((eq skipc ?\C-a)        ; type text
  1791.           (setq term (if atsw (teco-get-command nil) ?\C-a)
  1792.             atsw nil)
  1793.           (while (/= (teco-get-command nil) term)
  1794.         nil))            ; skip text
  1795.          ((eq skipc ?!)        ; tag 
  1796.           (if arg
  1797.           (throw 'teco-skip skipc))
  1798.           (while (/= (teco-get-command nil) ?!)
  1799.         nil))            ; skip until next !
  1800.          ((or (eq skipc ?e)
  1801.           (eq skipc ?f))    ; first char of two-letter E or F
  1802.                     ; command
  1803.           nil)))            ; not implemented
  1804.     (if (/= (logand ta 2) 0)    ; command with a text
  1805.                     ; argument
  1806.         (progn
  1807.           (setq term (if atsw (teco-get-command nil) ?\e)
  1808.             atsw nil)
  1809.           (while (/= (teco-get-command nil) term)
  1810.         nil)            ; skip text
  1811.           ))))))
  1812.  
  1813.  
  1814. (defvar teco-command-keymap
  1815.   ;; This is what used to be (make-vector 128 'teco-command-self-insert)
  1816.   ;; Oh well
  1817.   (let ((map (make-keymap)) (n 127))
  1818.     (while (>= n 0)
  1819.       (define-key map (if (< n 32) (list 'control (+ n 32)) n)
  1820.     'teco-command-self-insert)
  1821.       (setq n (1- n)))
  1822.     map)
  1823.   "Keymap used while reading teco commands.")
  1824.  
  1825. (define-key teco-command-keymap "\^g" 'teco-command-ctrl-g)
  1826. (define-key teco-command-keymap "\^m" 'teco-command-return)
  1827. (define-key teco-command-keymap "\^u" 'teco-command-ctrl-u)
  1828. (define-key teco-command-keymap "\e" 'teco-command-escape)
  1829. (define-key teco-command-keymap "\^?" 'teco-command-delete)
  1830.  
  1831. (defvar teco-command-escapes nil
  1832.   "Records where ESCs are, since they are represented in the command buffer
  1833. by $.")
  1834.  
  1835. ;;;###autoload
  1836. (defun teco-command ()
  1837.   "Read and execute a Teco command string."
  1838.   (interactive)
  1839.   (let* ((teco-command-escapes nil)
  1840.      (command (catch 'teco-command-quit
  1841.             (read-from-minibuffer teco-prompt nil
  1842.                       teco-command-keymap))))
  1843.     (if command
  1844.     (progn
  1845.       (while teco-command-escapes
  1846.         (aset command (car teco-command-escapes) ?\e)
  1847.         (setq teco-command-escapes (cdr teco-command-escapes)))
  1848.       (setq teco-output-buffer (get-buffer-create "*Teco Output*"))
  1849.       (save-excursion
  1850.         (set-buffer teco-output-buffer)
  1851.         (goto-char (point-max))
  1852.         (insert teco-prompt command))
  1853.       (teco-execute-command command)))))
  1854.  
  1855. (defun teco-read-command ()
  1856.   "Read a teco command string from the user."
  1857.   (let ((command (catch 'teco-command-quit
  1858.            (read-from-minibuffer teco-prompt nil
  1859.                      teco-command-keymap)))
  1860.     teco-command-escapes)
  1861.     (if command
  1862.     (while teco-command-escapes
  1863.       (aset command (car teco-command-escapes ?\e))
  1864.       (setq teco-command-escapes (cdr teco-command-escapes))))
  1865.     command))
  1866.  
  1867. (defun teco-command-self-insert ()
  1868.   (interactive)
  1869.   (insert last-command-char)
  1870.   (if (not (pos-visible-in-window-p))
  1871.       (enlarge-window 1)))
  1872.  
  1873. (defun teco-command-ctrl-g ()
  1874.   (interactive)
  1875.   (beep)
  1876.   (throw 'teco-command-quit nil))
  1877.  
  1878. (defun teco-command-return ()
  1879.   (interactive)
  1880.   (setq last-command-char ?\n)
  1881.   (teco-command-self-insert))
  1882.  
  1883. (defun teco-command-escape ()
  1884.   (interactive)
  1885.   ;; Two ESCs in a row terminate the command string
  1886.   (if (eq last-command 'teco-command-escape)
  1887.       (throw 'teco-command-quit (buffer-string)))
  1888.   (setq teco-command-escapes (cons (1- (point)) teco-command-escapes))
  1889.   (setq last-command-char ?$)
  1890.   (teco-command-self-insert))
  1891.  
  1892. (defun teco-command-ctrl-u ()
  1893.   (interactive)
  1894.   ;; delete the characters
  1895.   (kill-line 0)
  1896.   ;; forget that they were ESCs
  1897.   (while (and teco-command-escapes (<= (point) (car teco-command-escapes)))
  1898.       (setq teco-command-escapes (cdr teco-command-escapes)))
  1899.   ;; decide whether to shrink the window
  1900.   (while (let ((a (insert ?\n))
  1901.            (b (pos-visible-in-window-p))
  1902.            (c (backward-delete-char 1)))
  1903.        b)
  1904.     (shrink-window 1)))
  1905.  
  1906. (defun teco-command-delete ()
  1907.   (interactive)
  1908.   ;; delete the character
  1909.   (backward-delete-char 1)
  1910.   ;; forget that it was an ESC
  1911.   (if (and teco-command-escapes (= (point) (car teco-command-escapes)))
  1912.       (setq teco-command-escapes (cdr teco-command-escapes)))
  1913.   ;; decide whether to shrink the window
  1914.   (insert ?\n)
  1915.   (if (prog1 (pos-visible-in-window-p)
  1916.     (backward-delete-char 1))
  1917.       (shrink-window 1)))
  1918.  
  1919. (provide 'teco)
  1920.  
  1921. ;;; teco.el ends here
  1922.